home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / parassign.t < prev    next >
Encoding:
Text File  |  1990-06-08  |  18.8 KB  |  538 lines
  1. (herald (back_end parassign)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define-local-syntax (ass-comment string . rest)
  30.   `(if *assembly-comments?*
  31.        (emit-comment (format nil ,string ,@rest))))                      
  32.  
  33. ;;; ALLOCATE-CALL The "top".  Dispatch on the type of call.
  34.  
  35. (define (allocate-call node)
  36.   (if *call-break?* (breakpoint (pp-cps node)))
  37.   (let ((proc (call-proc node)))
  38.     (cond ((primop-node? proc)
  39.            (ass-comment "~s" (pp-cps node))
  40.            (allocate-primop-call node))
  41.           ((lambda-node? proc)
  42.            (generate-let node))
  43.           ((variable-known (leaf-value proc))
  44.            => (lambda (proc)                     
  45.                 (ass-comment "Call known procedure ~s" 
  46.                          (cons (lambda-name proc) (cdr (pp-cps node))))
  47.                 (xcond ((fx= (call-exits node) 0)
  48.                         (allocate-known-return node proc))
  49.                        ((fx= (call-exits node) 1)
  50.                         (allocate-known-call node proc)))))
  51.           ((fx= (call-exits node) 0)
  52.            (ass-comment "Return from procedure ~s" (pp-cps node))
  53.            (allocate-return node))
  54.           ((fx= (call-exits node) 1)
  55.            (ass-comment "Call unknown procedure ~s" (pp-cps node))
  56.            (allocate-general-call node))
  57.           (else
  58.            (bug "too many exits - ~s" node)))))
  59.  
  60. (define (allocate-known-call node proc)
  61.   (receive (cont moved)
  62.     (xselect (lambda-strategy proc)
  63.       ((strategy/label) (allocate-label-call node proc))
  64.       ((strategy/heap) (allocate-known-heap-call node proc)))
  65.     (if (call-in-body? proc node)
  66.     (cond (cont
  67.            (generate-save-jump-and-link proc)
  68.            (emit-stack-template cont moved)
  69.            (restore-live-registers-and-continue moved cont))
  70.           (else 
  71.            (generate-jump proc)
  72.            (clear-slots)))
  73.     (cond (cont
  74.            (generate-save-avoid-jump-and-link proc)
  75.            (emit-stack-template cont moved)
  76.            (restore-live-registers-and-continue moved cont))
  77.           (else 
  78.            (generate-avoid-jump proc)
  79.            (clear-slots))))))
  80.  
  81.  
  82. (define-constant (maybe-deallocate-red-frame node)
  83.   (emit maybe-popfr node))
  84.  
  85. (define (allocate-known-heap-call node proc)
  86.   (let* ((cont ((call-arg 1) node))
  87.      (out? (lambda-node? cont)))
  88.     (let ((moved (if out? (save-live-registers cont node) nil)))
  89.       (parallel-assign-general node)
  90.       (if (n-ary? proc) 
  91.       (generate-move (machine-num (length (call-args node))) NARGS))
  92.       (or out? (maybe-deallocate-red-frame *lambda*))
  93.       (return (and out? cont) moved))))
  94.  
  95.  
  96. (define (allocate-label-call node proc)
  97.   (let* ((join (get-or-set-join-state node proc))
  98.      (cont ((call-arg 1) node))
  99.      (out? (lambda-node? cont)))
  100.     (let ((moved (if out? (save-live-registers cont node) nil)))
  101.       (parallel-assign node
  102.                (cdr (call-args node))
  103.                (join-point-arg-specs join)
  104.                nil
  105.                (join-point-global-registers join))
  106.       (or out?
  107.       (not (fully-recursive? proc))
  108.       (maybe-deallocate-red-frame *lambda*))
  109.       (return (and out? cont) moved))))
  110.  
  111.                        
  112.                          
  113. (define (allocate-known-return node proc)
  114.   (xselect (lambda-strategy proc)
  115.     ((strategy/label) (allocate-label-return node proc))))
  116.  
  117.  
  118.  
  119. (define (allocate-label-return node proc)
  120.   (let ((join (get-or-set-join-state node proc)))
  121.     (cond ((not (n-ary? proc))
  122.            (parallel-assign node
  123.                             (call-args node)
  124.                             (join-point-arg-specs join)
  125.                             nil
  126.                             (join-point-global-registers join)))
  127.           ((used? (lambda-cont-var proc))
  128.        (let ((an-used? (and (any? lambda-node? (call-args node))
  129.                    (reg-node AN))))
  130.          (if an-used? (free-register node AN))
  131.          (parallel-assign node
  132.                   (call-args node)
  133.                   (join-point-arg-specs join)
  134.                   nil
  135.                   (join-point-global-registers join))
  136.          (if an-used? (generate-move (or (register-loc an-used?)
  137.                          (temp-loc an-used?))
  138.                      AN))))
  139.       (else
  140.            (really-parallel-assign node '() '()
  141.                    (join-point-global-registers join) nil))))
  142.   (clear-slots)
  143.   (generate-jump proc))
  144.  
  145. (define (allocate-conditional-continuation node proc-leaf)
  146.   (error "This should not happen ALLOCATE-CONDITIONAL-CONTINUATION"))
  147.   
  148.  
  149. (define (allocate-general-call node)
  150.   (let* ((cont ((call-arg 1) node))
  151.      (out? (lambda-node? cont)))
  152.     (let ((moved (if out? (save-live-registers cont node) nil)))
  153.     (parallel-assign-general node)
  154.     (cond (out?
  155.        (generate-general-call-and-link (reference-variable (call-proc node))
  156.                        (fx- (length (call-args node)) 1))
  157.        (emit-stack-template cont moved)
  158.        (restore-live-registers-and-continue moved cont))
  159.       (else
  160.       (maybe-deallocate-red-frame *lambda*)
  161.       (generate-general-call (reference-variable (call-proc node))
  162.                   (fx- (length (call-args node)) 1))
  163.        (clear-slots))))))
  164.  
  165.                                    
  166. (define (allocate-return node)
  167.   (parallel-assign-return node)      
  168.   (maybe-deallocate-red-frame *lambda*)
  169.   (clear-slots)
  170.   (generate-return (length (call-args node))))
  171.                          
  172.  
  173.  
  174.  
  175. (define (parallel-assign-general node)
  176.   (parallel-assign node (cons (call-proc node) (cdr (call-args node)))
  177.                         nil t '()))
  178.                                  
  179. (define (parallel-assign-return node)
  180.   (parallel-assign node (call-args node) nil nil '()))
  181.  
  182.  
  183. ;;; PARALLEL-ASSIGN Cons a closure if necessary.  It is known that there
  184. ;;; will only be one that needs to be consed.
  185.  
  186. (define (parallel-assign node args p-list proc? solve-list)
  187.   (let ((an-locked? (cond ((get-closure args)
  188.                => (lambda (closure)
  189.                 (make-heap-closure node closure)
  190.                 (lock AN)
  191.                 t))
  192.               (else nil))))
  193.     (receive (args pos-list) (do-reg-positions node args p-list proc?)
  194.       (really-parallel-assign node args pos-list solve-list an-locked?))))
  195.   
  196.  
  197. (define (get-closure args)
  198.   (any (lambda (arg)               
  199.          (and (lambda-node? arg)
  200.               (eq? (lambda-strategy arg) strategy/heap)
  201.               (neq? (environment-closure (lambda-env arg)) *unit*)
  202.               (environment-closure (lambda-env arg))))
  203.        args))
  204.  
  205.  
  206. ;;; do-now - register or temp pairs (source . target)
  207. ;;; trivial - immediate or lambda
  208. ;;; do-later - environment
  209. ;;; See implementor for this stuff. Hairy!!
  210.                        
  211. (define-structure-type arg-mover
  212.   from
  213.   to
  214. (((print self port)
  215.   (format port "{Arg-mover (~d ~d)}" (arg-mover-from self) (arg-mover-to self)))))
  216.  
  217. (define (mover from  to)
  218.   (let ((a (make-arg-mover)))
  219.     (set (arg-mover-from a) from)
  220.     (set (arg-mover-to a) to)
  221.     a))
  222.  
  223. (define (really-parallel-assign node args pos-list solve-list unlock?)
  224.   (receive (do-now trivial do-later) (sort-by-difficulty args pos-list)
  225.     (receive (do-now do-later) (add-on-free-list do-now do-later solve-list)
  226.       (solve node do-now do-later)                                    
  227.       (do-indirects node do-later)
  228.       (walk (lambda (pair)
  229.               (if (lambda-node? (car pair))
  230.                   (do-trivial-lambda (car pair) (cdr pair))))
  231.             trivial)
  232.       (if unlock? (unlock AN))
  233.       (walk (lambda (pair)
  234.               (if (not (lambda-node? (car pair)))
  235.                   (do-immediate (car pair) (cdr pair))))
  236.             trivial))))
  237.                                                       
  238.  
  239. (define (add-on-free-list do-now do-later solve-list)
  240.   (iterate loop ((pairs solve-list) (do-now do-now) (do-later do-later))
  241.     (cond ((null? pairs)
  242.            (return do-now do-later))
  243.           ((or (register-loc (cdar pairs))
  244.                (temp-loc (cdar pairs)))
  245.            => (lambda (reg)
  246.                 (loop (cdr pairs)
  247.                       (cons (mover reg (caar pairs))
  248.                             do-now)
  249.                       do-later)))
  250.           (else
  251.            (loop (cdr pairs)
  252.                  do-now
  253.                  (if (fx= (caar pairs) P)
  254.                      (append! do-later (list (cons (cdar pairs) P)))
  255.                      (cons (cons (cdar pairs) (caar pairs))
  256.                            do-later)))))))
  257.  
  258.  
  259. (define (sort-by-difficulty args pos-list)
  260.   (iterate loop ((args args) (do-now '()) (trivial '()) (do-later '())
  261.                  (pos-list pos-list))
  262.     (cond ((null? args)
  263.            (return do-now trivial do-later))
  264.           ((lambda-node? (car args)) 
  265.            (let ((l (car args)))
  266.              (cond ((eq? (environment-closure (lambda-env l)) *unit*)
  267.                     (loop (cdr args)
  268.                           do-now
  269.                           trivial
  270.                           (cons (cons l (car pos-list)) do-later)
  271.                           (cdr pos-list)))
  272.                    (else
  273.                     (loop (cdr args)
  274.                           do-now
  275.                           (cons (cons l (car pos-list)) trivial)
  276.                           do-later
  277.                           (cdr pos-list))))))
  278.           ((addressable? (leaf-value (car args)))
  279.            (loop (cdr args)
  280.                  do-now
  281.                  (cons (cons (car args) (car pos-list)) trivial)
  282.                  do-later
  283.                  (cdr pos-list)))
  284.           (else
  285.            (let* ((val (leaf-value (car args)))
  286.                   (value (cond ((and (variable? val) (variable-known val))
  287.                                => lambda-self-var)
  288.                               (else val))))
  289.              (cond ((let ((reg (register-loc value))
  290.                   (temp (temp-loc value)))
  291.                  (if (and reg temp (eq? temp (car pos-list)))
  292.                  temp
  293.               (or reg temp)))   
  294.                     => (lambda (reg)
  295.                          (loop (cdr args)
  296.                                (cons (mover reg (car pos-list))
  297.                                      do-now)
  298.                                trivial
  299.                                do-later
  300.                                (cdr pos-list))))
  301.                    (else
  302.                     (loop (cdr args)
  303.                           do-now
  304.                           trivial
  305.                           (if (fx= (car pos-list) P)
  306.                               (append! do-later (list (cons value (car pos-list))))
  307.                               (cons (cons value (car pos-list)) do-later))
  308.                           (cdr pos-list)))))))))
  309.  
  310.  
  311. (define (do-immediate node reg)
  312.   (generate-move-addressable (leaf-value node) reg))
  313.  
  314.  
  315. (define (do-indirects node do-later) 
  316.   (iterate loop ((items do-later))
  317.     (if items
  318.         (let ((item (car items))
  319.               (contour (lambda-self-var *heap-env*)))
  320.           (receive (mover target) (get-mover-and-target item) 
  321.             (cond ((eq? (register-loc contour) target)
  322.                    (if (cdr items)
  323.                        (loop (append (cdr items) (cons item '())))
  324.                        (mover node (car item) target)))
  325.           ((eq? (temp-loc contour) target)
  326.                    (cond ((not (cdr items))
  327.               (mover node (car item) target))
  328.              ((receive (#f target) (get-mover-and-target (cadr items))
  329.                (eq? (register-loc contour) target))
  330.               (set (temp-loc contour) nil)
  331.               (set (temp-node target) nil)
  332.               (mover node (car item) target)
  333.               (loop (cdr items)))
  334.              (else
  335.               (loop (append (cdr items) (cons item '()))))))
  336.                   (else
  337.                    (mover node (car item) target)
  338.                    (loop (cdr items)))))))))
  339.         
  340. (define (get-mover-and-target item)
  341.   (cond ((and (node? (car item)) 
  342.           (lambda-node? (car item)))
  343.      (return indirect-lambda (cdr item)))
  344.     (else
  345.      (return indirect-var (cdr item)))))
  346.  
  347.         
  348.  
  349. (define (indirect-lambda node lam target) 
  350.   (lambda-queue lam)
  351.   (generate-move (lookup node lam nil) target)
  352.   (unmark-reg target)
  353.   (lock target))
  354.  
  355. (define (indirect-var node var target)
  356.   (generate-move (lookup-value node var) target)
  357.   (unmark-reg target)
  358.   (mark var target)
  359.   (lock target))
  360.  
  361.  
  362.                    
  363. (define (unmark-reg reg)
  364.   (cond ((reg-node reg)
  365.          => (lambda (var)
  366.               (set (reg-node reg) nil)
  367.               (if (register? reg)
  368.                   (set (register-loc var) nil)
  369.                   (set (temp-loc var) nil))))))
  370.  
  371.                
  372. (define (solve node movers do-later)
  373.   (let* ((contour (lambda-self-var *heap-env*))
  374.      (tos (map arg-mover-to movers))
  375.      (vals (map reg-node tos))
  376.      (real-movers (filter need-to-move? movers))
  377.      (save-env
  378.        (and do-later
  379.                 (any (lambda (mover)
  380.                         (if (eq? (reg-node (arg-mover-to mover)) contour)
  381.                             mover
  382.                             nil))
  383.                       movers)))
  384.      (reg (or (register-loc contour) (temp-loc contour))))
  385.     (walk kill vals)
  386.     (walk lock tos)
  387.     (cond ((not save-env))
  388.       ((neq? (arg-mover-from save-env) (arg-mover-to save-env))
  389.        (let ((new (get-stack-slot node)))
  390.          (generate-move reg new)
  391.          (mark contour new)))
  392.       (else
  393.        (mark contour (arg-mover-to save-env))))
  394.     (do-assignment real-movers node)))
  395.  
  396. (define-constant (need-to-move? mover)
  397.   (not (eq? (reg-node (arg-mover-from mover))
  398.         (reg-node (arg-mover-to mover)))))
  399.  
  400.                            
  401. (define (do-assignment movers node)
  402.   (iterate loop1 ((movers movers)
  403.                   (targets (map arg-mover-to movers))
  404.                   (temp nil))
  405.     (cond ((null? movers))
  406.         (else
  407.          (iterate loop2 ((candidates targets))
  408.            (cond ((null? candidates)
  409.                   (let ((mover (car movers)))
  410.                     (generate-move (arg-mover-to mover) parassign-extra)
  411.                     (generate-move (arg-mover-from mover) (arg-mover-to mover))
  412.                     (loop1 (cdr movers)
  413.                            (delq (arg-mover-to mover) targets)
  414.                            (arg-mover-to mover))))
  415.                  ((not (mem? from-reg-eq? (car candidates) movers))
  416.                   (let ((mover (car (mem to-reg-eq? (car candidates) movers))))
  417.                     (generate-move 
  418.                          (cond ((eq? (arg-mover-from mover) temp) parassign-extra)
  419.                                (else
  420.                                 (arg-mover-from mover)))
  421.                          (arg-mover-to mover))
  422.                     (loop1 (delq mover movers)
  423.                            (delq (arg-mover-to mover) targets)
  424.                            temp)))
  425.                  (else
  426.                   (loop2 (cdr candidates)))))))))
  427.  
  428.  
  429.  
  430.  
  431. (define (to-reg-eq? reg mover) (fx= (arg-mover-to mover) reg))
  432. (define (from-reg-eq? reg mover) (fx= (arg-mover-from mover) reg))
  433.  
  434.  
  435. (define (save-live-registers cont node)
  436.   (modify (lambda-max-temps *lambda*)    ;make sure we have stack frame here
  437.       (lambda (max-temp)
  438.         (max 1 max-temp)))
  439.   (iterate loop ((vars (if '#t        ;fill in later
  440.                (let ((contour (lambda-self-var *heap-env*))
  441.                  (live (lambda-live cont)))
  442.                  (if (memq? contour live)
  443.                  live
  444.                  (cons contour live)))
  445.                (lambda-live cont)))
  446.          (moved '()))
  447.     (if (null? vars) 
  448.     moved
  449.     (let* ((var (car vars))
  450.            (mover
  451.         (cond ((temp-loc var)
  452.                => (lambda (temp)
  453.                 (let ((reg (register-loc var)))
  454.                   (if (and reg (fx>= reg *first-stack-register*))
  455.                   (cons var (cons reg temp))
  456.                   (cons var temp)))))
  457.               ((register-loc var)
  458.                => (lambda (reg)
  459.                 (cond ((fx>= reg *first-stack-register*)
  460.                    (cons var reg))
  461.                   (else
  462.                    (let ((new
  463.                       (cond
  464.                        ((likely-next-reg var cont)
  465.                         => (lambda (new)
  466.                          (if (or (reg-node new)
  467.                              (fx< new *first-stack-register*))
  468.                              (get-stack-slot node)
  469.                              new)))
  470.                        (else
  471.                         (get-stack-slot node)))))
  472.                      (generate-move reg new)
  473.                      (lock new)
  474.                      (cons var new))))))
  475.               (else '#f))))
  476.       (if mover
  477.           (loop (cdr vars) (cons mover moved))
  478.           (loop (cdr vars) moved))))))
  479.     
  480. (define (restore-live-registers-and-continue moved cont)
  481.   (let ((node (lambda-body cont)))
  482.     (clear-slots)
  483.     (if (nary-setup-needed? cont)
  484.     (generate-nary-setup cont (length (lambda-variables cont))))
  485.     (do ((vars (lambda-variables cont) (cdr vars))
  486.      (reg A1 (fx+ reg 1)))
  487.     ((or (fx>= reg AN) (null? vars))
  488.      (cond (vars
  489.         (let ((used (used-registers moved)))
  490.         (do ((vars vars (cdr vars))
  491.              (reg (next-not-used *first-stack-register* used)
  492.               (next-not-used (fx+ reg 1) used)))
  493.             ((null? vars)
  494.              (modify (lambda-max-temps *lambda*)
  495.                  (lambda (temps) (max temps (fx- reg 1)))))
  496.           (cond ((and (car vars) (variable-refs (car vars)))
  497.              (mark (car vars) reg)
  498.              (generate-extra-arg-move reg))))))))
  499.       (cond ((and (car vars) (variable-refs (car vars)))
  500.          (mark (car vars) reg))))
  501.     (walk (lambda (moved)
  502.         (destructure (((var . regs) moved))
  503.               (cond ((atom? regs)
  504.              (mark var regs))
  505.             (else
  506.              (mark var (car regs)) ;reg
  507.              (mark var (cdr regs)))))) ;temp
  508.       moved)
  509.     (allocate-call node)))
  510.  
  511. (define (next-not-used reg moved)
  512.   (cond ((memq? reg moved)
  513.      (next-not-used (fx+ reg 1) moved))
  514.     (else reg)))
  515.  
  516. (define (used-registers moved)
  517.   (iterate loop ((moved moved) (used '()))
  518.     (cond ((null? moved) used)
  519.       (else
  520.        (destructure (((#f . regs) (car moved)))
  521.          (if (atom? regs)
  522.          (loop (cdr moved) (cons regs used))
  523.          (loop (cdr moved) (cons (car regs) (cons (cdr regs) used)))))))))
  524.  
  525. ;; the following is to special case a join which is nary and used to
  526. ;; strategy/stack in non-risc versions
  527.  
  528. (define (nary-setup-needed? node)
  529.   (and (n-ary? node)
  530.        (or (used? (lambda-rest-var node))
  531.        (let* ((body (lambda-body node))
  532.           (proc (call-proc body)))
  533.          (and (fx= (call-exits body) 0)
  534.           (reference-node? proc)
  535.           (let ((known (variable-known (reference-variable proc))))
  536.             (and known (n-ary? known))))))))
  537.        
  538.